home *** CD-ROM | disk | FTP | other *** search
/ Aminet 24 / Aminet 24 (1998)(GTI - Schatztruhe)[!][Apr 1998].iso / Aminet / dev / lang / PPCcforth.lha / PPCcforth / prims.c < prev    next >
C/C++ Source or Header  |  1985-12-27  |  11KB  |  486 lines
  1. /*
  2.  * prims.c -- code for the primitive functions declared in forth.dict
  3.  */
  4.  
  5. #include <stdio.h>
  6. #include <ctype.h>    /* used in "digit" */
  7. #include "common.h"
  8. #include "forth.h"
  9. #include "prims.h"    /* macro primitives */
  10.  
  11. /*
  12.              ----------------------------------------------------
  13.                             PRIMITIVE DEFINITIONS
  14.              ----------------------------------------------------
  15. */
  16.  
  17. zbranch()            /* add an offset (branch) if tos == 0 */
  18. {
  19.     if(pop() == 0) 
  20.         ip += mem[ip];
  21.     else
  22.         ip++;        /* else skip over the offset */
  23. }
  24.  
  25. ploop()                /* (loop) -- loop control */
  26. {
  27.     short index, limit;
  28.     index = rpop()+1;
  29.     if(index < (limit = rpop())) {   /* if the new index < the limit */
  30.         rpush(limit);    /* restore the limit */
  31.         rpush(index);    /* and the index (incremented) */
  32.         branch();    /* and go back to the top of the loop */
  33.     }
  34.     else ip++;             /* skip over the offset, and exit, having
  35.                    popped the limit & index */
  36. }
  37.  
  38. pploop()            /* (+loop) -- almost the same */
  39. {
  40.     short index, limit;
  41.     index = rpop()+pop();        /* get index & add increment */
  42.     if(index < (limit = rpop())) {    /* if new index < limit */
  43.         rpush (limit);        /* restore the limit */
  44.         rpush (index);        /* restore the new index */
  45.         branch();        /* and branch back to the top */
  46.     }
  47.     else {
  48.         ip++;        /* skip over branch offset */
  49.     }
  50. }
  51.  
  52. pdo()            /* (do): limit init -- [pushed to rstack] */
  53. {
  54.     swap();
  55.     rpush (pop());
  56.     rpush (pop());
  57. }
  58.  
  59. i()            /* copy top of return stack to cstack */
  60. {
  61.     int tmp;
  62.     tmp = rpop();
  63.     rpush(tmp);
  64.     push(tmp);
  65. }
  66.  
  67. r()        /* this must be a primitive as well as I because otherwise it
  68.            always returns its own address */
  69. {
  70.     i();
  71. }
  72.  
  73. digit()            /* digit: c -- FALSE or [v TRUE] */
  74. {
  75.     short c, base;        /* C is ASCII char, convert to val. BASE is
  76.                    used for range checking */
  77.     base = pop();
  78.     c = pop();
  79.     if (!isascii(c)) {
  80.     push (FALSE);
  81.     return;
  82.     }
  83.                  /* lc -> UC if necessary */
  84.     if (islower(c)) c = toupper(c);
  85.  
  86.     if (c < '0' || (c > '9' && c < 'A') || c > 'Z') {
  87.     push(FALSE);        /* not a digit */
  88.     }
  89.     else {            /* it is numeric or UC Alpha */
  90.     if (c >= 'A') c -= 7;    /* put A-Z right after 0-9 */
  91.  
  92.     c -= '0';        /* now c is 0..35 */
  93.  
  94.     if (c >= base) {
  95.         push (FALSE);    /* FALSE - not a digit */
  96.     }
  97.     else {            /* OKAY: push value, then TRUE */
  98.         push (c);
  99.         push (TRUE);
  100.     }
  101.     }
  102. }
  103.  
  104. pfind()        /* WORD TOP -- xx FLAG, where TOP is NFA to start at;
  105.            WORD is the word to find; xx is PFA of found word;
  106.            yy is actual length of the word found;
  107.            FLAG is 1 if found. If not found, 0 alone is stacked. */
  108. {
  109.     unsigned short  worka, workb, workc, current, word, match;
  110.  
  111.     current = pop ();
  112.     word = pop ();
  113.     while (current) {        /* stop at end of dictionary */
  114.     if (!((mem[current] ^ mem[word]) & 0x3f)) {
  115.                 /* match lengths & smudge */
  116.         worka = current + 1;/* point to the first letter */
  117.         workb = word + 1;
  118.         workc = mem[word];    /* workc gets count */
  119.         match = TRUE;    /* initally true, for looping */
  120.         while (workc-- && match)
  121.         match = ((mem[worka++] & 0x7f) == (mem[workb++] & 0x7f));
  122.         if (match) {    /* exited with match TRUE -- FOUND IT */
  123.         push (worka + 2);        /* worka=LFA; push PFA */
  124.         push (mem[current]);        /* push length byte */
  125.         push (TRUE);            /* and TRUE flag */
  126.         return;
  127.         }
  128.     }
  129.     /* failed to match */
  130.     /* follow link field to next word */
  131.     current = mem[current + (mem[current] & 0x1f) + 1];
  132.     }
  133.     push (FALSE);        /* current = 0; end of dict; not found */
  134. }
  135.  
  136. enclose()
  137. {
  138.     int delim, current, offset;
  139.  
  140.     delim = pop();
  141.     current = pop();
  142.     push (current);
  143.  
  144.     offset = -1;
  145.     current--;
  146. encl1:
  147.     current++;
  148.     offset++;
  149.     if (mem[current] == delim) goto encl1;
  150.  
  151.     push(offset);
  152.     if (mem[current] == NULL) {
  153.         offset++;
  154.         push (offset);
  155.         offset--;
  156.         push (offset);
  157.         return;
  158.     }
  159.  
  160. encl2:
  161.     current++;
  162.     offset++;
  163.     if (mem[current] == delim) goto encl4;
  164.     if (mem[current] != NULL) goto encl2;
  165.  
  166.     /* mem[current] is null.. */
  167.     push (offset);
  168.     push (offset);
  169.     return;
  170.  
  171. encl4:    /* found the trailing delimiter */
  172.     push (offset);
  173.     offset++;
  174.     push (offset);
  175.     return;
  176. }
  177.  
  178. cmove()            /* cmove: source dest number -- */
  179. {
  180.     short source, dest, number, i;
  181.     number = pop();
  182.     dest = pop();
  183.     source = pop();
  184.     for ( ; number ; number-- ) mem[dest++] = mem[source++];
  185. }
  186.  
  187. fill()            /* fill: c dest number -- */
  188. {
  189.     short dest, number, c;
  190.     number = pop();
  191.     dest = pop();
  192.     c = pop();
  193.  
  194.     mem[dest] = c;        /* always at least one */
  195.     if (number == 1) return;    /* return if only one */
  196.  
  197.     push (dest);        /* else push dest as source of cmove */
  198.     push (dest + 1);        /* dest+1 as dest of cmove */
  199.     push (number - 1);        /* number-1 as number of cmove */
  200.     cmove();
  201. }
  202.  
  203. ustar()                /* u*: a b -- a*b.hi a*b.lo */
  204. {
  205.     unsigned short a, b;
  206.     unsigned long c;
  207.     a = (unsigned short)pop();
  208.     b = (unsigned short)pop();
  209.     c = a * b;
  210.  
  211.     /* (short) -1 is probably FFFF, which is just what we want */
  212.     push ((unsigned short)(c & (short) -1));          /* low word of product */
  213.                              /* high word of product */
  214.     push ((short)((c >> (8*sizeof(short))) & (short) -1));
  215. }
  216.  
  217. uslash()            /* u/: NUM.LO NUM.HI DENOM -- REM QUOT */
  218. {
  219.     unsigned short numhi, numlo, denom;
  220.     unsigned short quot, remainder;    /* the longs below are to be sure the
  221.                        intermediate computation is done
  222.                        long; the results are short */
  223.     denom = pop();
  224.     numhi = pop();
  225.     numlo = pop();
  226.     quot = ((((unsigned long)numhi) << (8*sizeof(short))) 
  227.                 + (unsigned long)numlo) 
  228.                     / (unsigned long)denom;
  229.  
  230.     remainder = ((((unsigned long)numhi) << (8*sizeof(short))) 
  231.                 + (unsigned long)numlo) 
  232.                     % (unsigned long)denom;
  233.  
  234.     push (remainder);
  235.     push (quot);
  236. }
  237.  
  238. swap()                /* swap: a b -- b a */
  239. {
  240.     short a, b;
  241.     b = pop();
  242.     a = pop();
  243.     push (b);
  244.     push (a);
  245. }
  246.  
  247. rot()                /* rotate */
  248. {
  249.     short a, b, c;
  250.     a = pop ();
  251.     b = pop ();
  252.     c = pop ();
  253.     push (b);
  254.     push (a);
  255.     push (c);
  256. }
  257.  
  258. tfetch()            /* 2@: addr -- mem[addr+1] mem[addr] */
  259. {
  260.     unsigned short addr;
  261.     addr = pop();
  262.     push (mem[addr + 1]);
  263.     push (mem[addr]);
  264. }
  265.  
  266. store()            /* !: val addr -- <set mem[addr] = val> */
  267. {
  268.     unsigned short tmp;
  269.     tmp = pop();
  270.     mem[tmp] = pop();
  271. }
  272.  
  273. cstore()            /* C!: val addr --  */
  274. {
  275.     store();
  276. }
  277.  
  278. tstore()            /* 2!: val1 val2 addr -- 
  279.                    mem[addr] = val2,
  280.                    mem[addr+1] = val1 */
  281. {
  282.     unsigned short tmp;
  283.     tmp = pop();
  284.     mem[tmp] = pop();
  285.     mem[tmp+1] = pop();
  286. }
  287.  
  288. leave()            /* set the index = the limit of a DO */
  289. {
  290.     int tmp;
  291.     rpop();            /* discard old index */
  292.     tmp = rpop();        /* and push the limit as */
  293.     rpush(tmp);            /* both the limit */
  294.     rpush(tmp);            /* and the index */
  295. }
  296.  
  297. dplus()                /* D+: double-add */
  298. {
  299.     short ahi, alo, bhi, blo;
  300.     long a, b;
  301.     bhi = pop();
  302.     blo = pop();
  303.     ahi = pop();
  304.     alo = pop();
  305.     a = ((long)ahi << (8*sizeof(short))) + (long)alo;
  306.     b = ((long)bhi << (8*sizeof(short))) + (long)blo;
  307.     a = a + b;
  308.     push ((unsigned short)(a & (short) -1));    /* sum lo */
  309.     push ((short)(a >> (8*sizeof(short))));    /* sum hi */
  310. }
  311.  
  312. subtract()            /* -: a b -- (a-b) */
  313. {
  314.     int tmp;
  315.     tmp = pop();
  316.     push (pop() - tmp);
  317. }
  318.  
  319. dsubtract()            /* D-: double-subtract */
  320. {
  321.     short ahi, alo, bhi, blo;
  322.     long a, b;
  323.     bhi = pop();
  324.     blo = pop();
  325.     ahi = pop();
  326.     alo = pop();
  327.     a = ((long)ahi << (8*sizeof(short))) + (long)alo;
  328.     b = ((long)bhi << (8*sizeof(short))) + (long)blo;
  329.     a = a - b;
  330.     push ((unsigned short)(a & (short) -1));    /* diff lo */
  331.     push ((short)(a >> (8*sizeof(short))));    /* diff hi */
  332. }
  333.  
  334. dminus()                /* DMINUS: negate a double number */
  335. {
  336.     unsigned short ahi, alo;
  337.     long a;
  338.     ahi = pop();
  339.     alo = pop();
  340.     a = -(((long)ahi << (8*sizeof(short))) + (long)alo);
  341.     push ((unsigned short)(a & (short) -1));        /* -a lo */
  342.     push ((unsigned short)(a >> (8*sizeof(short))));     /* -a hi */
  343. }
  344.  
  345. over()                /* over: a b -- a b a */
  346. {
  347.     short a, b;
  348.     b = pop();
  349.     a = pop();
  350.     push (a);
  351.     push (b);
  352.     push (a);
  353. }
  354.  
  355. dup()                /* dup: a -- a a */
  356. {
  357.     short a;
  358.     a = pop();
  359.     push (a);
  360.     push (a);
  361. }
  362.  
  363. tdup()            /* 2dup: a b -- a b a b */
  364. {
  365.     short a, b;
  366.     b = pop();
  367.     a = pop();
  368.     push (a);
  369.     push (b);
  370.     push (a);
  371.     pus